home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software 2000
/
Software 2000 Volume 1 (Disc 1 of 2).iso
/
education
/
e030.dms
/
e030.adf
/
Evolution
/
evolution4.f
< prev
next >
Wrap
Text File
|
1989-09-24
|
12KB
|
537 lines
\ Evolution by Russ Yost
\
\ Simulate the evolution of bugs, the insect kind, that eat
\ bacteria. The bugs genes control the directions they turn.
\ Bugs that find the most bacteria to eat survive better
\ and pass their genes to their offspring. Mutation and
\ other aspects of evolution are modelled. See ReadMe file.
\
\ This program has been placed in the Public Domain by the
\ author and may be freely redistributed if accompanied
\ by the ReadMe file.
\
\ This program was written using JForth Professional 2.0
\ from Delta Research
getmodule includes
include? gr.init ju:amiga_graph
include? ?closebox ju:amiga_events
include? :struct ju:c_struct
include? wchoose ju:random
include? value ju:value
anew task-bugs
forth definitions
newwindow bugwindow
10 constant gr_xmin 620 constant gr_xmax
gr_xmax gr_xmin - constant gr_xspan
5 constant gr_ymin 137 constant gr_ymax
gr_ymax gr_ymin - constant gr_yspan
65534 constant sf \ scale factor for random integer genes
65535 constant sf+1 \ random number multiplier
750 constant bact0 variable bact-rate variable bugs-to-do
variable g.e.mode false g.e.mode !
4 constant g.e.lim \ of each of 12 uniform dist'n summed to get
\ pseudo-Gaussian distribution.
10 constant max.tries
\ variable n-time
32 constant n-rpt \ output status after processing n-rpt bugs.
40 constant bacte 600 constant bugemax 10 constant bugs0
variable numbugs
variable mature 200 mature ! variable too.old
mature @ 10 * too.old !
variable strong 400 strong !
variable child.e 40 child.e !
variable child.e.half false child.e.half !
create xmoves 0 , 4 , 4 , 0 , -4 , -4 ,
create ymoves 2 , 1 , -1 , -2 , -1 , 1 ,
: get.params \ future use to set parameters. May require changing
\ some constants to variables.
;
6 array geneavs
:struct bugdat
aptr bg_prev
aptr bg_next
short bg_x
short bg_y
short bg_dir
7 4 * bytes bg_gene
short bg_e
short bg_a
;struct
\ Set up initial bugstructs in fast mem.
0 value bug0 0 value bug1 \ Inlz self-fetching bugpointers.
: make.bug0 ( -- bgptr )
memf_fast sizeof() bugdat allocblock
dup 0= abort" Can't make bug0." dup -> bug0
;
: make.bug1 ( -- bgptr )
memf_fast sizeof() bugdat allocblock
dup 0= abort" Can't make bug1." dup -> bug1
;
: bact.set ( x, y -- , paint color 3 bacterium, )
gr.color@ >r 3 gr.color!
2dup gr.move gr.draw
r> gr.color! ;
: init.rand rand-seed >abs dup call intuition_lib CurrentTime drop ;
: rx gr_xmax gr_xmin wchoose 2/ 2* ; \ To align bugs and bacts
: ry gr_ymax gr_ymin wchoose ; \ and to reduce search time in eating.
: rdir 6 choose ;
: grx ( -- x ) \ Gaussian distn at ctr of window
0 12 0 do
g.e.lim 2* 1+ dup negate 1+ wchoose +
loop
gr_xmax gr_xmin + 2/ + 2/ 2*
;
: gry ( -- y ) \ Gaussian distn at ctr of window
0 12 0 do
g.e.lim 1+ dup negate 1+ wchoose +
loop
gr_ymax gr_ymin + 2/ +
;
: g.e.rand.bact.set ( -- ) \ look for clear spot for max.tries,
\ put bact in Raleigh Distn.
0 ( inlz counter ) 0 dup ( inlz x, y )
begin
2drop 1+ ( inc. cntr ) grx gry 2dup
gr-currport @ -rot call graphics_lib ReadPixel
0=
3 pick max.tries > or
until
>r >r drop r> r>
bact.set
;
: rand.bact.set ( -- ; look for a clear spot before putting a bact. )
0 dup
begin
2drop rx ry 2dup
gr-currport @ -rot call graphics_lib ReadPixel
0=
until
bact.set
;
: rand.bacts.add ( -- )
bact-rate @
begin
dup 0>
while
g.e.mode @ if g.e.rand.bact.set
else rand.bact.set
then
1-
repeat
drop
;
: getxy ( bgptr -- bgptr x y )
dup ..@ bg_x over ..@ bg_y
;
: bug.paint ( bgptr -- bgptr ) ( uses existing gr.color )
\ if = background color, clears existing bug.
getxy ( -- bgptr, x, y ; x,y is lower left corner of 4x2 bug )
1- over 3 + over 1+ gr.rect
;
: bug.set ( bgptr -- bgptr )
gr.color@ >r
dup ..@ bg_e dup
child.e @ 80 + >
if drop 1
else child.e @ >
if 3 else 2
then
then
gr.color!
bug.paint
r> gr.color!
;
: bug.clear ( bgptr -- bgptr )
gr.color@ >r 0 gr.color!
bug.paint
r> gr.color!
;
: make,link.inl.pair ( -- )
bug0 dup 0= if drop make.bug0 then
bug1 dup 0= if drop make.bug1 then
over over ..! bg_prev
over over ..! bg_next
swap
over over ..! bg_prev
..! bg_next
;
: inlz.initial.bug.genes ( bgptr -- bgptr )
dup .. bg_gene
0 over !
7 1 do 6000 choose
over i 1- cells + @ +
over i cells + ! loop drop
;
: inlz.xydea ( bgptr -- bgptr )
rx over ..! bg_x
ry over ..! bg_y
rdir over ..! bg_dir
bacte over ..! bg_e
0 over ..! bg_a
;
: make.nu.bug ( bgptr -- nubgptr )
memf_fast sizeof() bugdat allocblock ( bgptr, nubgptr | false)
dup 0= abort" Can't make new bug. "
( bgptr, nubgptr )
over ..@ bg_next dup >r ( b0ptr , nubptr, nxtbptr )
over ..! bg_next ( b0ptr, nubgptr )
r@ ..@ bg_prev over ..! bg_prev
dup rot ..! bg_next
dup r> ..! bg_prev
1 numbugs +!
;
: inlz.bug.data ( bgptr -- bgptr )
inlz.initial.bug.genes inlz.xydea bug.set
;
: inlz.set.bugs ( -- )
make,link.inl.pair
bug0 inlz.bug.data drop bug1 inlz.bug.data drop
2 numbugs !
bug0 \ add nu bugs after bug0.
bugs0 2 - 0 do make.nu.bug inlz.bug.data loop drop
;
: get.next.bug ( bgptr -- nextbgptr )
..@ bg_next
;
: .gr.prob. ( n -- ; print n as decimal fractn )
" ." gr.text dup 100 <
if 0 gr.number
then dup 10 <
if 0 gr.number
then
gr.number
;
: .avg.genes ( bgptr -- bgptr )
6 0 do 0 i geneavs ! loop
dup >r \ save for comparison to detect complete chain
begin ( bgptr )
dup .. bg_gene ( bgptr, genebase )
7 1 do dup i cells + @
over i 1- cells + @
- 1000 2 pick 24 + @ */
i 1- geneavs +!
loop drop ( bgptr )
get.next.bug ( nextbgptr ) dup r@ =
until
r> drop numbugs @
6 0 do i geneavs @ over / .gr.prob. " ; " gr.text
loop drop
;
: report ( bgptr, -- bgptr )
0 145
" Turn, degrees : 0 60 120 180 240 300"
gr.xytext
0 155 " # Bugs: " gr.xytext numbugs @
dup 100 < if " " gr.text then
dup 10 < if " " gr.text then gr.number
" ; Avg Gene Probabilities: " gr.text .avg.genes
520 170 " " gr.xytext
520 170 gr.move bact-rate @
bacte * 2/ gr.number
;
: test.kill.bug ( bgptr -- bgptr | nextbgptr )
numbugs @ 2 >
if
dup ..@ bg_e 0=
over ..@ bg_a too.old @ > or
if
bug.clear
dup ..@ bg_prev
over ..@ bg_next
dup 2 pick ..! bg_next
over over ..! bg_prev
-rot drop ( nextbugptr, bgptr )
dup bug0 = if 0 -> bug0 else dup bug1 = if 0 -> bug1 then then
freeblock \ Return dead bug's memory space.
-1 numbugs +!
report
then
else
dup ..@ bg_e 0 max over ..! bg_e \ Keep last two bugs energy positive.
then
;
: getturn ( bugstructureptr -- same; bugdir[n] changed per genes )
dup .. bg_gene
dup 6 cells + @ choose ( bptr, g0, pturn )
0 dup ( bptr, g0, pturn, ix, T0 )
begin
2 pick <
swap 4 + dup 24 < rot and
while ( bp, g0, pturn, index )
dup 3 pick + @
repeat ( bp, g0, pturn, selected index )
4 / 2- >r 2drop r> ( bp, selected.turn in 0..5 range )
over ..@ bg_dir + 6 mod
over ..! bg_dir
;
: getnuxy ( bgptr -- bgptr )
dup ..@ bg_dir dup >r
cells xmoves + @ ( bugptr, delx )
over ..@ bg_x + ( bugptr, newx )
gr_xmax over <
if gr_xspan -
else gr_xmin over >
if gr_xspan +
then
then
over ..! bg_x ( bugptr )
r> ( get dir )
cells ymoves + @
over ..@ bg_y + ( bgptr, ytrial )
gr_ymax over <
if gr_yspan -
else gr_ymin over >
if gr_yspan +
then
then
over ..! bg_y
dup ..@ bg_a 1+
over ..! bg_a
dup ..@ bg_e 1-
over ..! bg_e
;
: eat.bact ( bgptr, x, y, port, xf, port, xf, yf --- bgptr, x, y, port, xf )
call graphics_lib ReadPixel ( bgptr, x, y, port, xf, color.id )
3 =
if
4 pick ..@ bg_e bacte +
dup bugemax >
if
drop bugemax
then
5 pick ..! bg_e
then
;
: eat.bg.bacts ( bgptr -- bgptr )
dup ..@ bg_x over ..@ bg_y gr-currport @ ( bgptr, x, y, port )
4 0 do
2 pick i + ( bp, x, y, port, xf
2 0 do
2dup 4 pick i - eat.bact
loop drop
2 +loop 2drop drop
;
: copy.bug.data ( srcbgptr, destbgptr -- same )
over ..@ bg_x over ..! bg_x
over ..@ bg_y over ..! bg_y
over ..@ bg_dir over ..! bg_dir
over .. bg_gene over .. bg_gene 28 move
;
: div.all.genes.by.2 ( bptr -- bptr )
dup .. bg_gene
28 4 do dup i + dup @ 2/ swap !
cell +loop drop
;
: inc.rand.gene ( bgptr -- )
rdir 1+ dup >r
over .. bg_gene dup >r
swap cells + dup @
swap 4 - @ - ( bgptr, Ti-Ti-1 )
r> r> cells
begin ( bgptr, delT, g0, ix )
2dup + 3 pick swap +!
4 + dup 24 >
until
+ 4 - @ ( bgptr, delT, T6 [=sum] )
>r drop r>
65535 > if div.all.genes.by.2 then drop
;
: dec.rand.gene ( bgptr -- )
rdir 1+ dup >r
over .. bg_gene dup >r
swap cells + dup @
swap 4 - @ - 2/ negate ( bgptr, delT )
r> r> cells ( bp, delT, g0, ix )
begin
2dup + dup @ 4 pick + swap !
4 + dup 24 >
until
2drop 2drop
;
: fission ( bgptr -- bgptr )
dup ..@ bg_a mature @ >
if
dup ..@ bg_e strong @ >
if
dup make.nu.bug ( oldbgptr, nubgptr )
copy.bug.data ( oldbgptr, nubgptr )
over inc.rand.gene
dup dec.rand.gene
child.e.half @
if
over ..@ bg_e 2/
else
child.e @
then
dup 3 pick ..! bg_e
over ..! bg_e ( oldbgptr, nubugptr )
0 dup 2 pick ..! bg_a 2 pick ..! bg_a drop
report
then
then
;
: chng.bact ( 67 | 68 | 69 -- )
\ If n = 67, toggle g.e.mode.
\ If n = 68, decrements bact-rate by 1, but not < 0;
\ If n = 69, increments bact-rate by 1;
\ else doesn't change nubact.
case 67 of g.e.mode dup @ true xor swap ! 0 endof
68 of -1 endof
69 of 1 endof
0 swap
endcase bact-rate +!
bact-rate dup @ 0<
if 0 swap ! else drop then
;
: make.buttons ( -- ) ( Adapted from Delta Research )
0 160 60 175 gr.rect
80 160 140 175 gr.rect
160 160 310 175 gr.rect
JAM1 gr.mode! 0 gr.color!
10 170 " Dec." gr.xytext
90 170 " Inc." gr.xytext
170 170 " Uniform/Conc." gr.xytext
JAM2 gr.mode! 1 gr.color!
;
: check.input ( bugptr -- bugptr quitflag )
gr-curwindow @ ev.getclass ?dup
IF
CASE
MOUSEBUTTONS OF
ev-last-code @ SELECTDOWN =
IF ev.getxy00 ( Xm, Ym -- ) 150 >
IF ( Xm )
dup 320 <
if
dup 80 <
if
drop 68 chng.bact report
else
160 <
if
69 chng.bact report
else
67 chng.bact
then
then
else drop
then
else drop
then
then false
endof
CLOSEWINDOW of true endof
false swap
endcase
else false
then
;
: evolve ( -- )
gr.init ( to be certain )
bugwindow newwindow.setup
bugwindow
0" Bug Evolution R.Yost" >abs over ..! nw_Title
190 swap ..! nw_Height
CLOSEWINDOW MOUSEBUTTONS | bugwindow ..! nw_idcmpflags
bugwindow gr.opencurw not abort" Couldn't open window."
1 gr.color! \ Set foreground color to white.
make.buttons
320 170 " New bacts supplied for ~ bugs" gr.xytext
init.rand
get.params
bact0 bact-rate !
rand.bacts.add
1 bact-rate !
inlz.set.bugs
numbugs @ 2* bugs-to-do !
bug0
report
begin
n-rpt 0 DO
eat.bg.bacts
bug.set
test.kill.bug
get.next.bug
fission
getturn
bug.clear
getnuxy
bugs-to-do dup >r @ 1- dup r> ! 0=
if
rand.bacts.add
numbugs @ 2* bugs-to-do !
then
LOOP
check.input
until
drop gr.closecurw gr.term
;
cr ." Enter: EVOLVE to run program." cr